home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / Yerk 3.6.6 / Float source / fpi⁄o < prev    next >
Encoding:
Text File  |  1993-12-27  |  6.6 KB  |  127 lines  |  [TEXT/YERK]
  1. \ FPI/O -- floating-point I/O support for 68000 SANE engine.
  2. \    5/11/85     ssg Version 1.0
  3. \    9/26/85     cbd Modified for float heap, removed minor methods
  4. \    2/07/86     gdc Added words atof and f.r, changed eprint to eprint, printxyz
  5. \    8/16/86     cdn Eliminated finit & Stringer shorten
  6. \    5/26/91     rfl Eliminated Stringer class altogether.
  7. \ 10/26/91    rfl abs in front of /mod
  8. \ 12/17/92    rfl fixed a few problems that might occur due to not locking handles
  9. \ 01/26/93    rfl protect parse: to reject a possible float if 2 decimal points are mistakenly
  10. \                 adjacent. The case of " 1.234.56" is interpreted as an integer
  11. \ 12/03/93    rfl fixed problem with non FPU machines returning garbage exp when
  12. \                0 is passed to num2dec in float2dec:. Thanks to Harry Haddon.
  13. \                Removed 2 bytes scratch -use pad instead. Removed if true else false
  14. \ 12/05/93    rfl    Rewrote much of the formatting routines and added ability to
  15. \                get addr len of format on stack. More use of pack7 utilities.
  16.  
  17. Decimal
  18.  
  19. \ Some useful constants
  20. 256 constant neg
  21.     0 constant pos
  22. 256 constant FixedDecimal
  23.     0 constant FloatDecimal
  24.     0 value topxyz                \ top of string being converted to float
  25.  
  26. 0 variable valid?            \ used for scan: but never used otherwise...mhore
  27.  
  28. \ reentrant code to get rid of leading zeros - not used here
  29. \ : endZ ( addr -- addr) dup c@ ascii 0 = IF 1+ endZ THEN ;
  30.  
  31. :CLASS        FPI/O    <Super Object
  32.  
  33.             \ SANE Record Decimal ( x:= (-1)^sgn * 10^exp * SigDig )
  34.             INT sgn        \ sign; 0=pos, 256=neg
  35.             INT exp        \ as if decimal point were to the right of SigDig
  36.             22 BYTES SigDig \ to fake string[20] ; 22 to make even
  37.  
  38.             \ SANE Record DecForm
  39.             INT style    \ Float=0; Fixed=256
  40.             INT digits    \ # of sig digits,if float; # dec. places,if fixed.
  41.  
  42.             string     floater         \ to hold formatted output string
  43.             string     expStr            \ to hold formatted exponent string
  44.             var         places            \ number of places to right of dec. pt.
  45.  
  46.             int index
  47.  
  48. ( -- )
  49.   :M    CLEAR:    addr: sgn 26 erase unlock: floater clear: floater clear: expstr ;M
  50.  
  51. ( -- )    \ Initialize strings etc.
  52.   :M    INIT:    new: floater new: expStr clear: self ;M
  53.  
  54. ( -- )
  55.   :M    EINIT:    clear: self FloatDecimal put: style ( 19 put: digits)    ;M
  56.  
  57. ( -- )    \ Initialize for fixed conversion
  58.   :M    FINIT:    clear: self FixedDecimal put: style        ;M
  59.  
  60. ( -- )    \ Puts a zero in decimal record
  61.   :M    ZERO:    clear: self     $ 0130 addr: sigDig w!        ;M
  62.  
  63. ( -- float )    \ ==== attempt to convert decimal to a float;
  64.   :M    DEC2FLOAT:    { \ flt     -- flt }
  65.         abs: sgn    \ Addr of decimal record
  66.         new: fltMem -> flt    flt 2+ +base    \ Absolute Destination address
  67.         $ 0009 \ FFEXT FOD2B + -- Opcode for decimal to binary; dest=extended
  68.         fp68k        flt            \ Call FP68K
  69.     ;M
  70.  
  71. ( float -- )            \ ==== convert float to decimal     ==== \
  72.   :M    FLOAT2DEC:    { flt -- }
  73.         abs: style     \ Absolute Addr of Decform record
  74.         flt 2+ +base            \ Absolute Addr of source
  75.         abs: sgn    \ Absolute Addr of Decimal record
  76.         $ 000b \ FFEXT FOB2D + -- Opcode for binary to decimal; source=extended
  77.         fp68k    flt fdrop        \ Call FP68K, dispose of float
  78. \         addr: sigDig 1+ c@ ascii 0 =
  79. \         IF clear: exp THEN
  80.     ;M
  81.  
  82. ( -- )    \ Set up float for in decimal record in scientific format,
  83. \                            left-justified in a field of width characters.
  84.   :M    num2dec: float2dec: self
  85.         abs: style (abs) pad +base call dec2str
  86.         pad count put: floater ;M
  87.  
  88.   :M    ROUND: ( f -- f') 1 swap 0 do 10 * LOOP >float fdup >r f* round r> f/ ;M
  89.  
  90. ( flt width -- addr len)
  91.   :M    GETEText: { width \ pos -- addr len } 
  92.             einit: self
  93.             num2dec: self
  94.             start: floater ascii e charof: floater
  95.             IF drop size: floater substr: floater put: expStr
  96.                 width size: expStr - 3 max                \ bl or -, digit, decimal minimum
  97.                 size: floater size: expStr - min -> pos \ keep at least 2 numbers for decimal
  98.  
  99.                 pos moveto: floater                    \ round up NEED
  100.  
  101.                 size: floater substr: floater get: expStr replace: floater
  102.             ELSE addr: sigDig count drop c@
  103.                 dup ascii I = IF pad 1+ 1 put: floater
  104.                                 " Infinity" add: floater
  105.                                  width 10 - 0 DO bl +: floater LOOP
  106.                                 THEN
  107.                     ascii N = IF pad 1+ 1 put: floater width 14 >
  108.                                 IF " Not a number " add: floater
  109.                                      width 14 - 
  110.                                 ELSE " NaN " add: floater
  111.                                      width 5 -
  112.                                 THEN 
  113.                                 0 DO bl +: floater LOOP
  114.                                 THEN
  115.             THEN    lock: floater get: floater ;M
  116.  
  117.   :M EPRINT: geteText: self type ;M
  118.                                  \ Carry out f.r
  119.   :M GETFText: { width decimal \ dot -- addr len }
  120.     finit: self
  121.     decimal round: self num2dec: self
  122.     start: floater ascii . charof: floater
  123.     IF -> dot
  124.         decimal abs 1+ subStr: floater put: expStr
  125.         get: sgn not IF start: floater bl pad c! pad 1 insert: floater 1 ++> dot THEN
  126.         dot moveto: floater
  127.         size: floater substr: flo